home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / runtime / io-primitives.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  15.9 KB  |  530 lines  |  [TEXT/CCL2]
  1. ine (prim.format-error? e) (eq? (car e) 'format-error))
  2. (define (prim.search-error? e) (eq? (car e) 'search-error))
  3. (define (prim.other-error? e)  (eq? (car e) 'other-error))
  4. (define (prim.eof-error? e)    (eq? (car e) 'eof-error))
  5.  
  6. (define (prim.make-read-error s)   (cons 'read-error s))
  7. (define (prim.make-write-error s)  (cons 'write-error s))
  8. (define (prim.make-format-error s) (cons 'format-error s))
  9. (define (prim.make-search-error s) (cons 'search-error s))
  10. (define (prim.make-other-error s)  (cons 'other-error s))
  11. (define prim.eof-error             (cons 'eof-error '#f))
  12.  
  13. (define (prim.read-error-string e)   (force (cdr e)))
  14. (define (prim.write-error-string e)  (force (cdr e)))
  15. (define (prim.format-error-string e) (force (cdr e)))
  16. (define (prim.search-error-string e) (force (cdr e)))
  17. (define (prim.other-error-string e)  (force (cdr e)))
  18.  
  19. (define (prim.show-error e)
  20.   (let ((str  (if (cdr e)
  21.           (haskell-string->string (force (cdr e)))
  22.           '#f)))
  23.     (case (car e)
  24.       (read-error     (string-append "Read Error: " str))
  25.       (write-error    (string-append "Write Error: " str))
  26.       (format-error   (string-append "Format Error: " str))
  27.       (search-error   (string-append "Search Error: " str))
  28.       (other-error    (string-append "Other Error: " str))
  29.       (eof-error      "End of File"))))
  30.  
  31.  
  32.  
  33. ;;; Instead of the Either/PrimIO mechanism for handling IO errors described
  34. ;;; in the Haskell 1.3 proposal, we handle IO errors using a catch/throw
  35. ;;; mechanism.  Here are the low-level guts of this mechanism.
  36.  
  37. (define *io-error-handler*
  38.   (lambda (e)
  39.     (haskell-runtime-error (prim.show-error e))))
  40.  
  41. (define-syntax (with-io-error-handler f . body)
  42.   (let ((croak  (gensym))
  43.     (e      (gensym)))
  44.     `(let/cc ,croak
  45.        (dynamic-let ((*io-error-handler*
  46.                (lambda (,e)
  47.              (funcall ,croak (funcall ,f ,e)))))
  48.      ,@body))))
  49.  
  50. (define-syntax (haskell-io-error e)
  51.   `(funcall (dynamic *io-error-handler*) ,e))
  52.  
  53.  
  54. ;;; Macros for signaling specific types of errors.
  55.  
  56. (define-syntax (haskell-read-error s . args)
  57.   `(haskell-io-error
  58.      (prim.make-read-error
  59.        (box (make-haskell-string (format '#f ,s ,@args))))))
  60. (define-syntax (haskell-write-error s . args)
  61.   `(haskell-io-error
  62.      (prim.make-write-error
  63.        (box (make-haskell-string (format '#f ,s ,@args))))))
  64. (define-syntax (haskell-format-error s . args) 
  65.   `(haskell-io-error
  66.      (prim.make-format-error
  67.        (box (make-haskell-string (format '#f ,s ,@args))))))
  68. (define-syntax (haskell-search-error s . args)
  69.   `(haskell-io-error
  70.      (prim.make-search-error
  71.        (box (make-haskell-string (format '#f ,s ,@args))))))
  72. (define-syntax (haskell-other-error s . args) 
  73.   `(haskell-io-error
  74.      (prim.make-other-error
  75.        (box (make-haskell-string (format '#f ,s ,@args))))))
  76. (define-syntax (haskell-eof-error)
  77.   `(haskell-io-error prim.eof-error))
  78.  
  79.  
  80. ;;; Here are implementations for the primitive IO functions.
  81.  
  82. (define-integrable (prim.thenio p q s)   ;; strictness S N
  83.   (let ((x  (funcall p s)))
  84.     (funcall (force q) (box x) s)))
  85.  
  86. (define-integrable (prim.seqio p q s)    ;; strictness S N
  87.   (funcall p s)
  88.   (funcall (force q) s))
  89.  
  90. (define-integrable (prim.applyio p q)    ;; strictness S N
  91.   (funcall (force q) (box p)))
  92.  
  93. (define-integrable (prim.failwith x s)   ;; strictness S
  94.   (declare (ignore s))
  95.   (haskell-io-error x))
  96.  
  97. (define (prim.try p q s)                 ;; strictness S N
  98.   (with-io-error-handler
  99.       (lambda (e) (funcall (force q) (box e) s))
  100.     (funcall p s)))
  101.  
  102.  
  103.  
  104. ;;; These macros are provided to support Lisp/Haskell datatype
  105. ;;; conversion, to do the (a -> IOResult a) and (IOResult a -> a)
  106. ;;; conversions, respectively.
  107.  
  108. (define-syntax (io-return x) `(box ,x))
  109. (define-syntax (io-result x) `(force ,x))
  110.  
  111.  
  112.  
  113. ;;;=======================================================================
  114. ;;; Handles
  115. ;;;=======================================================================
  116.  
  117.  
  118. ;;; The handle type incorporates both a pointer to the underlying
  119. ;;; stream and various status information for Haskell.
  120. ;;; We don't support control over echoing or buffering.
  121.  
  122. (define-struct prim.handle
  123.   (slots
  124.    (stream (type t))
  125.    (name   (type string))
  126.    (kind   (type (enum :input-only :output-only :input-output)))
  127.    (open   (type (enum :is-open    :is-closed   :is-semi-closed)))
  128.    (file   (type bool))
  129.    (buff   (type (enum :unbuffered :line :block)) (default :block))
  130.    (echo   (type bool) (default '#f))
  131.    ))
  132.  
  133.  
  134. (define (prim.print-handle handle stream)
  135.   (format stream "<<Handle for ~a ~s>>"
  136.     (if (prim.handle-file handle) "file" "channel")
  137.     (prim.handle-name handle)))
  138.  
  139. (define-struct-printer prim.handle prim.print-handle)
  140.  
  141. (define (prim.show-handle handle)
  142.   (prin1-to-string handle))
  143.  
  144.  
  145.  
  146.  
  147. ;;; Define the standard handles
  148.  
  149. (define prim.stdin
  150.   (make prim.handle
  151.     (stream (current-input-port))
  152.     (name "stdin")
  153.     (kind ':input-only)
  154.     (open ':is-open)
  155.     (file '#f)))
  156.  
  157. (define prim.stdout
  158.   (make prim.handle
  159.     (stream (current-output-port))
  160.     (name "stdout")
  161.     (kind ':output-only)
  162.     (open ':is-open)
  163.     (file '#f)))
  164.  
  165. (define prim.stderr
  166.   (make prim.handle
  167.     (stream (current-error-port))
  168.     (name "stderr")
  169.     (kind ':output-only)
  170.     (open ':is-open)
  171.     (file '#f)))
  172.  
  173. (define prim.stdnull
  174.   (make prim.handle
  175.     (stream (lisp:make-two-way-stream
  176.           (lisp:make-concatenated-stream)
  177.           (lisp:make-broadcast-stream)))
  178.     (name "stdnull")
  179.     (kind ':input-output)
  180.     (open ':is-open)
  181.     (file '#f)))
  182.  
  183.  
  184.  
  185. ;;; Input from stdin is read by means of a hook function appropriate to
  186. ;;; the user interface.  Input is always line buffered.
  187. ;;; *** Maybe the line buffering should be moved into the command interface
  188. ;;; *** so that it presents a character-oriented interface to the I/O system.
  189.  
  190. (predefine *haskell-input-hook*)
  191.  
  192. (define *haskell-stdin-buffer* "")
  193. (define *haskell-stdin-size* 0)
  194. (define *haskell-stdin-index* 0)
  195.  
  196. (define (haskell-stdin-buffer-empty?)
  197.   (not (< (the fixnum *haskell-stdin-index*)
  198.       (the fixnum *haskell-stdin-size*))))
  199.  
  200. (define (haskell-stdin-read-char)
  201.   (cond ((haskell-stdin-buffer-empty?)
  202.      (multiple-value-bind (str eof?) (funcall *haskell-input-hook*)
  203.        (if (eof-object? str)
  204.            str
  205.            (begin
  206.          (setf *haskell-stdin-buffer*
  207.                (if eof?
  208.                str
  209.                (string-append str (string #\newline))))
  210.          (setf *haskell-stdin-index* 1)
  211.          (setf *haskell-stdin-size*
  212.                (string-length *haskell-stdin-buffer*))
  213.          (string-ref *haskell-stdin-buffer* 0)))))
  214.     (else
  215.      (let ((ch  (string-ref *haskell-stdin-buffer* *haskell-stdin-index*)))
  216.        (incf (the fixnum *haskell-stdin-index*))
  217.        ch))
  218.     ))
  219.  
  220.  
  221.  
  222. ;;; Keep track of open handles.
  223.  
  224. (define *open-handles* '())
  225.  
  226.  
  227.  
  228. ;;; File positioning.
  229.  
  230. (define (check-handle-seekable op handle)
  231.   (let ((open    (prim.handle-open handle))
  232.     (file    (prim.handle-file handle)))
  233.     (cond ((not (eq? open ':is-open))
  234.        (haskell-other-error
  235.          "~a failed on ~a: handle not open." op handle))
  236.       ((not file)
  237.        (haskell-other-error
  238.          "~a failed on ~a: not a file." op handle))
  239.       (else
  240.        '#t))))
  241.  
  242. (define (prim.handle-size handle)
  243.   (check-handle-seekable "hSize" handle)
  244.   (or (lisp:file-length (prim.handle-stream handle))
  245.       (haskell-other-error
  246.         "hSize failed on ~a: file not seekable." handle)))
  247.  
  248. (define (prim.handle-posn handle)
  249.   (check-handle-seekable "hPosn" handle)
  250.   (or (lisp:file-position (prim.handle-stream handle))
  251.       (haskell-other-error
  252.         "hPosn failed on ~a: file not seekable." handle)))
  253.  
  254. (define (prim.seek handle posn)
  255.   (check-handle-seekable "seek" handle)
  256.   (or (with-error-handler
  257.           (lambda (s)
  258.         (declare (ignore s))
  259.         (haskell-search-error
  260.           "seek failed on ~a: Lisp error." handle))
  261.     (lisp:file-position (prim.handle-stream handle) posn))
  262.       (haskell-search-error
  263.         "seek failed on ~a: file not seekable." handle)))
  264.  
  265.  
  266. ;;; Buffering and echoing control
  267.  
  268. (define (prim.set-buffering handle mode)
  269.   (unless (eq? mode (prim.handle-buff handle))
  270.     (haskell-write-error
  271.       "setBuffering failed on ~a: not implemented." handle)))
  272.  
  273. (define (prim.set-echoing handle mode)
  274.   (unless (eq? mode (prim.handle-echo handle))
  275.     (haskell-other-error
  276.      "setEchoing failed on ~a: not implemented." handle)))
  277.  
  278.  
  279.  
  280.   
  281. ;;;=======================================================================
  282. ;;; Open/close operations
  283. ;;;=======================================================================
  284.  
  285.  
  286.  
  287. ;;; *** This does not attempt to do any of the locking stuff described in
  288. ;;; *** the I/O proposal.  
  289.  
  290. (define (prim.open-file mode name)
  291.   (let* ((stream
  292.       (with-error-handler
  293.           (lambda (s)
  294.             (declare (ignore s))
  295.             (haskell-search-error
  296.           "openFile failed on ~s: Lisp error." name))
  297.         (case mode
  298.           ((:read)    (open-input-file name))
  299.           ((:write)   (open-output-file name))
  300.           ((:append)  (open-append-file name)))))
  301.      (handle
  302.       (make prim.handle
  303.         (stream stream)
  304.         (name name)
  305.         (kind (if (eq? mode ':read) ':input-only ':output-only))
  306.         (open :is-open)
  307.         (file '#t))))
  308.     (push handle (dynamic *open-handles*))
  309.     handle))
  310.  
  311.  
  312. ;;; *** This is supposed to open a pipe.
  313.  
  314. (define (prim.open-chan name)
  315.   (haskell-search-error "openChan failed on ~s: not implemented." name))
  316.  
  317.  
  318. (define (prim.flush handle)
  319.   (check-handle-writable "flush" handle)
  320.   (force-output (prim.handle-stream handle)))
  321.  
  322. (define (prim.close handle)
  323.   (let ((open    (prim.handle-open handle))
  324.     (stream  (prim.handle-stream handle)))
  325.     (if (not (eq? open ':is-closed))
  326.     (begin
  327.        (setf (prim.handle-open handle) ':is-closed)
  328.        ;; Don't really close standard streams.
  329.        (unless (or (eq? handle prim.stdin)
  330.                (eq? handle prim.stdout)
  331.                (eq? handle prim.stderr)
  332.                (eq? handle prim.stdnull))
  333.          (lisp:close stream)))
  334.         (haskell-other-error "close failed on ~a: handle already closed."
  335.                  handle))))
  336.  
  337.  
  338.  
  339. ;;;=======================================================================
  340. ;;; Input operations on handles
  341. ;;;=======================================================================
  342.  
  343. (define (check-handle-readable op handle)
  344.   (let ((kind    (prim.handle-kind handle))
  345.     (open    (prim.handle-open handle)))
  346.     (cond ((not (or (eq? kind ':input-only) (eq? kind ':input-output)))
  347.        (haskell-read-error
  348.          "~a failed on ~a: handle not readable." op handle))
  349.       ((not (eq? open ':is-open))
  350.        (haskell-read-error
  351.          "~a failed on ~a: handle not open." op handle))
  352.       (else
  353.        '#t))))
  354.  
  355. (define (prim.ready handle)
  356.   (check-handle-readable "ready" handle)
  357.   (if (eq? handle prim.stdin)
  358.       (or (not (haskell-stdin-buffer-empty?))
  359.       (listen (prim.handle-stream handle)))
  360.       (listen (prim.handle-stream handle))))
  361.  
  362. (define (prim.get-char handle)
  363.   (check-handle-readable "hGetChar" handle)
  364.   (let ((ch  (if (eq? handle prim.stdin)
  365.          (haskell-stdin-read-char)
  366.              (read-char (prim.handle-stream handle)))))
  367.     (if (eof-object? ch)
  368.     (haskell-eof-error)
  369.         ch)))
  370.  
  371.  
  372. ;;; This function has to be declared with noConversion because it returns
  373. ;;; a delay rather than a boxed result.
  374.  
  375. (define (prim.get-contents handle state)
  376.   (declare (ignore state))
  377.   (check-handle-readable "getContents" handle)
  378.   (setf (prim.handle-open handle) ':is-semi-closed)
  379.   (if (and (eq? handle prim.stdin)
  380.        (not (haskell-stdin-buffer-empty?)))
  381.       (delay (make-haskell-string-tail
  382.            (substring *haskell-stdin-buffer*
  383.               *haskell-stdin-index* *haskell-stdin-size*)
  384.            (delay (get-contents-file handle))))
  385.       (delay (get-contents-file handle))))
  386.  
  387.  
  388. ;;; If someone is stupid enough to close the handle before 
  389. ;;; all of the input has been read, treat it as though EOF has been
  390. ;;; reached, but don't signal error.
  391.  
  392. (define (get-contents-file handle)
  393.   (if (eq? (prim.handle-open handle) ':is-closed)
  394.       '()
  395.       (multiple-value-bind (str eof?)
  396.       (if (eq? handle prim.stdin)
  397.           (funcall *haskell-input-hook*)
  398.           (read-line (prim.handle-stream handle)))
  399.     (if (eof-object? str)
  400.         '()
  401.         (make-haskell-string-tail
  402.           str
  403.           (if eof?
  404.           (box '())
  405.           (box (cons (box (char->integer #\newline))
  406.                  (delay (get-contents-file handle))))))))))
  407.  
  408.  
  409.  
  410. ;;;=======================================================================
  411. ;;; Output operations on handles
  412. ;;;=======================================================================
  413.  
  414. (define (check-handle-writable op handle)
  415.   (let ((kind    (prim.handle-kind handle))
  416.     (open    (prim.handle-open handle)))
  417.     (cond ((not (or (eq? kind ':output-only) (eq? kind ':input-output)))
  418.        (haskell-write-error
  419.          "~a failed on ~a: handle not writable." op handle))
  420.       ((not (eq? open ':is-open))
  421.        (haskell-write-error
  422.          "~a failed on ~a: handle not open." op handle))
  423.       (else
  424.        '#t))))
  425.  
  426. (define (prim.put-char handle ch)
  427.   (check-handle-writable "hPutChar" handle)
  428.   (write-char ch (prim.handle-stream handle)))
  429.  
  430.  
  431.  
  432. ;;;=======================================================================
  433. ;;; Operating system interaction
  434. ;;;=======================================================================
  435.  
  436. (define (prim.delete-file name)
  437.   (or (with-error-handler
  438.           (lambda (s)
  439.         (declare (ignore s))
  440.         (haskell-search-error
  441.           "deleteFile failed on ~s: Lisp error." name))
  442.     (delete-file name))
  443.       (haskell-search-error "deleteFile failed on ~s." name)))
  444.  
  445. (define (prim.status-file name)
  446.   (if (file-exists? name)
  447.       "frw"
  448.       (haskell-search-error
  449.         "statusFile failed on ~s: file does not exist." name)))
  450.  
  451.  
  452. (predefine *haskell-command-line-args*)   ; in interface-prims.scm
  453. (predefine *haskell-program-name*)        ; in interface-prims.scm
  454.  
  455. (define (prim.getargs)
  456.   (dynamic *haskell-command-line-args*))
  457.  
  458. (define (prim.getprogname)
  459.   (dynamic *haskell-program-name*))
  460.  
  461. (define (prim.getenv name)
  462.   (getenv name))
  463.  
  464. (define (prim.setenv name value)
  465.   (declare (ignore name value))
  466.   (haskell-other-error "setEnv not implemented"))
  467.  
  468.  
  469.  
  470. ;;; Haskell wants time encoded in microseconds since Jan 1, 1970 GMT.
  471.  
  472. (define-integrable timebase (lisp:encode-universal-time 0 0 0 1 1 1970 0))
  473.  
  474. (define (prim.getclock)
  475.   (* (the integer (- (the integer (lisp:get-universal-time))
  476.              (the integer timebase)))
  477.      1000))
  478.  
  479.  
  480. (define *initial-cpu-time* 0)
  481.  
  482. (define-integrable cpu-time-factor
  483.   (/ 1000 lisp:internal-time-units-per-second))
  484.  
  485. (define (prim.getcputime)
  486.   (let ((current  (lisp:get-internal-run-time)))
  487.     (* (the integer (- (the integer current)
  488.                (the integer (dynamic *initial-cpu-time*))))
  489.        cpu-time-factor)))
  490.  
  491.  
  492.  
  493. ;;; *** do something about this.
  494.  
  495. (define (prim.run-process progname new-stdin new-stdout new-stderr)
  496.   (declare (ignore progname new-stdin new-stdout new-stderr))
  497.   (haskell-other-error "runProcess failed: not implemented."))
  498.  
  499. (define (prim.system progname)
  500.   (declare (ignore progname))
  501.   (haskell-other-error "system failed: not implemented."))
  502.  
  503.  
  504.  
  505. ;;;=======================================================================
  506. ;;; Initialization
  507. ;;;=======================================================================
  508.  
  509. ;;; *** Need to change command interface to call this.
  510.  
  511. (define-syntax (with-io-system . body)
  512.   `(begin
  513.      ;; Reset the standard handles.
  514.      (setf (prim.handle-open prim.stdin) ':is-open)
  515.      (setf (prim.handle-open prim.stdout) ':is-open)
  516.      (setf (prim.handle-open prim.stderr) ':is-open)
  517.      (setf (prim.handle-open prim.stdnull) ':is-open)
  518.      (setf *haskell-stdin-index* 0)
  519.      (setf *haskell-stdin-size* 0)
  520.      ;; Force output and close any handles left open after executing the body.
  521.      (dynamic-let ((*open-handles*      '())
  522.            (*initial-cpu-time*  (lisp:get-internal-run-time)))
  523.        (unwind-protect (begin ,@body)
  524.      (force-output (current-output-port))
  525.      (force-output (current-error-port))
  526.      (dolist (h *open-handles*)
  527.        (unless (eq? (prim.handle-open h) ':is-closed)
  528.          (lisp:close (prim.handle-stream h)))))))
  529.   )
  530.